home *** CD-ROM | disk | FTP | other *** search
/ Freelog 125 / Freelog_MarsAvril2015_No125.iso / ViePratique / gnucash / gnucash-2.6.5-setup.exe / {app} / bin / intltool-merge~ < prev    next >
Text File  |  2008-09-23  |  40KB  |  1,549 lines
  1. #!/opt/perl/bin/perl -w
  2. # -*- Mode: perl; indent-tabs-mode: nil; c-basic-offset: 4  -*-
  3.  
  4. #
  5. #  The Intltool Message Merger
  6. #
  7. #  Copyright (C) 2000, 2003 Free Software Foundation.
  8. #  Copyright (C) 2000, 2001 Eazel, Inc
  9. #
  10. #  Intltool is free software; you can redistribute it and/or
  11. #  modify it under the terms of the GNU General Public License 
  12. #  version 2 published by the Free Software Foundation.
  13. #
  14. #  Intltool is distributed in the hope that it will be useful,
  15. #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17. #  General Public License for more details.
  18. #
  19. #  You should have received a copy of the GNU General Public License
  20. #  along with this program; if not, write to the Free Software
  21. #  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22. #
  23. #  As a special exception to the GNU General Public License, if you
  24. #  distribute this file as part of a program that contains a
  25. #  configuration script generated by Autoconf, you may include it under
  26. #  the same distribution terms that you use for the rest of that program.
  27. #
  28. #  Authors:  Maciej Stachowiak <mjs@noisehavoc.org>
  29. #            Kenneth Christiansen <kenneth@gnu.org>
  30. #            Darin Adler <darin@bentspoon.com>
  31. #
  32. #  Proper XML UTF-8'ification written by Cyrille Chepelov <chepelov@calixo.net>
  33. #
  34.  
  35. ## Release information
  36. my $PROGRAM = "intltool-merge";
  37. my $PACKAGE = "intltool";
  38. my $VERSION = "0.40.4";
  39.  
  40. ## Loaded modules
  41. use strict; 
  42. use Getopt::Long;
  43. use Text::Wrap;
  44. use File::Basename;
  45.  
  46. my $must_end_tag      = -1;
  47. my $last_depth        = -1;
  48. my $translation_depth = -1;
  49. my @tag_stack = ();
  50. my @entered_tag = ();
  51. my @translation_strings = ();
  52. my $leading_space = "";
  53.  
  54. ## Scalars used by the option stuff
  55. my $HELP_ARG = 0;
  56. my $VERSION_ARG = 0;
  57. my $BA_STYLE_ARG = 0;
  58. my $XML_STYLE_ARG = 0;
  59. my $KEYS_STYLE_ARG = 0;
  60. my $DESKTOP_STYLE_ARG = 0;
  61. my $SCHEMAS_STYLE_ARG = 0;
  62. my $RFC822DEB_STYLE_ARG = 0;
  63. my $QUOTED_STYLE_ARG = 0;
  64. my $QUOTEDXML_STYLE_ARG = 0;
  65. my $QUIET_ARG = 0;
  66. my $PASS_THROUGH_ARG = 0;
  67. my $UTF8_ARG = 0;
  68. my $MULTIPLE_OUTPUT = 0;
  69. my $cache_file;
  70.  
  71. ## Handle options
  72. GetOptions 
  73. (
  74.  "help" => \$HELP_ARG,
  75.  "version" => \$VERSION_ARG,
  76.  "quiet|q" => \$QUIET_ARG,
  77.  "oaf-style|o" => \$BA_STYLE_ARG, ## for compatibility
  78.  "ba-style|b" => \$BA_STYLE_ARG,
  79.  "xml-style|x" => \$XML_STYLE_ARG,
  80.  "keys-style|k" => \$KEYS_STYLE_ARG,
  81.  "desktop-style|d" => \$DESKTOP_STYLE_ARG,
  82.  "schemas-style|s" => \$SCHEMAS_STYLE_ARG,
  83.  "rfc822deb-style|r" => \$RFC822DEB_STYLE_ARG,
  84.  "quoted-style" => \$QUOTED_STYLE_ARG,
  85.  "quotedxml-style" => \$QUOTEDXML_STYLE_ARG,
  86.  "pass-through|p" => \$PASS_THROUGH_ARG,
  87.  "utf8|u" => \$UTF8_ARG,
  88.  "multiple-output|m" => \$MULTIPLE_OUTPUT,
  89.  "cache|c=s" => \$cache_file
  90.  ) or &error;
  91.  
  92. my $PO_DIR;
  93. my $FILE;
  94. my $OUTFILE;
  95.  
  96. my %po_files_by_lang = ();
  97. my %translations = ();
  98. my $iconv = $ENV{"ICONV"} || "iconv";
  99. my $devnull = ($^O eq 'MSWin32' ? 'NUL:' : '/dev/null');
  100.  
  101. sub isProgramInPath
  102. {
  103.     my ($file) = @_;
  104.     # If either a file exists, or when run it returns 0 exit status
  105.     return 1 if ((-x $file) or (system("$file -l >$devnull") == 0));
  106.     return 0;
  107. }
  108.  
  109. if (! isProgramInPath ("$iconv"))
  110. {
  111.     print STDERR " *** iconv is not found on this system!\n".
  112.              " *** Without it, intltool-merge can not convert encodings.\n";
  113.     exit;
  114. }
  115.  
  116. # Use this instead of \w for XML files to handle more possible characters.
  117. my $w = "[-A-Za-z0-9._:]";
  118.  
  119. # XML quoted string contents
  120. my $q = "[^\\\"]*";
  121.  
  122. ## Check for options. 
  123.  
  124. if ($VERSION_ARG) 
  125. {
  126.     &print_version;
  127. } 
  128. elsif ($HELP_ARG) 
  129. {
  130.     &print_help;
  131. } 
  132. elsif ($BA_STYLE_ARG && @ARGV > 2) 
  133. {
  134.     &utf8_sanity_check;
  135.     &preparation;
  136.     &print_message;
  137.     &ba_merge_translations;
  138.     &finalize;
  139. } 
  140. elsif ($XML_STYLE_ARG && @ARGV > 2) 
  141. {
  142.     &utf8_sanity_check;
  143.     &preparation;
  144.     &print_message;
  145.     &xml_merge_output;
  146.     &finalize;
  147. } 
  148. elsif ($KEYS_STYLE_ARG && @ARGV > 2) 
  149. {
  150.     &utf8_sanity_check;
  151.     &preparation;
  152.     &print_message;
  153.         &keys_merge_translations;
  154.     &finalize;
  155. } 
  156. elsif ($DESKTOP_STYLE_ARG && @ARGV > 2) 
  157. {
  158.     &utf8_sanity_check;
  159.     &preparation;
  160.     &print_message;
  161.     &desktop_merge_translations;
  162.     &finalize;
  163. } 
  164. elsif ($SCHEMAS_STYLE_ARG && @ARGV > 2) 
  165. {
  166.     &utf8_sanity_check;
  167.     &preparation;
  168.     &print_message;
  169.     &schemas_merge_translations;
  170.     &finalize;
  171. } 
  172. elsif ($RFC822DEB_STYLE_ARG && @ARGV > 2) 
  173. {
  174.     &preparation;
  175.     &print_message;
  176.     &rfc822deb_merge_translations;
  177.     &finalize;
  178. } 
  179. elsif (($QUOTED_STYLE_ARG || $QUOTEDXML_STYLE_ARG) && @ARGV > 2)
  180. {
  181.     &utf8_sanity_check;
  182.     &preparation;
  183.     &print_message;
  184.     "ed_merge_translations($QUOTEDXML_STYLE_ARG);
  185.     &finalize;
  186. } 
  187. else 
  188. {
  189.     &print_help;
  190. }
  191.  
  192. exit;
  193.  
  194. ## Sub for printing release information
  195. sub print_version
  196. {
  197.     print <<_EOF_;
  198. ${PROGRAM} (${PACKAGE}) ${VERSION}
  199. Written by Maciej Stachowiak, Darin Adler and Kenneth Christiansen.
  200.  
  201. Copyright (C) 2000-2003 Free Software Foundation, Inc.
  202. Copyright (C) 2000-2001 Eazel, Inc.
  203. This is free software; see the source for copying conditions.  There is NO
  204. warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  205. _EOF_
  206.     exit;
  207. }
  208.  
  209. ## Sub for printing usage information
  210. sub print_help
  211. {
  212.     print <<_EOF_;
  213. Usage: ${PROGRAM} [OPTION]... PO_DIRECTORY FILENAME OUTPUT_FILE
  214. Generates an output file that includes some localized attributes from an
  215. untranslated source file.
  216.  
  217. Mandatory options: (exactly one must be specified)
  218.   -b, --ba-style         includes translations in the bonobo-activation style
  219.   -d, --desktop-style    includes translations in the desktop style
  220.   -k, --keys-style       includes translations in the keys style
  221.   -s, --schemas-style    includes translations in the schemas style
  222.   -r, --rfc822deb-style  includes translations in the RFC822 style
  223.       --quoted-style     includes translations in the quoted string style
  224.       --quotedxml-style  includes translations in the quoted xml string style
  225.   -x, --xml-style        includes translations in the standard xml style
  226.  
  227. Other options:
  228.   -u, --utf8             convert all strings to UTF-8 before merging 
  229.                          (default for everything except RFC822 style)
  230.   -p, --pass-through     deprecated, does nothing and issues a warning
  231.   -m, --multiple-output  output one localized file per locale, instead of 
  232.                      a single file containing all localized elements
  233.   -c, --cache=FILE       specify cache file name
  234.                          (usually \$top_builddir/po/.intltool-merge-cache)
  235.   -q, --quiet            suppress most messages
  236.       --help             display this help and exit
  237.       --version          output version information and exit
  238.  
  239. Report bugs to http://bugzilla.gnome.org/ (product name "$PACKAGE")
  240. or send email to <xml-i18n-tools\@gnome.org>.
  241. _EOF_
  242.     exit;
  243. }
  244.  
  245.  
  246. ## Sub for printing error messages
  247. sub print_error
  248. {
  249.     print STDERR "Try `${PROGRAM} --help' for more information.\n";
  250.     exit;
  251. }
  252.  
  253.  
  254. sub print_message 
  255. {
  256.     print "Merging translations into $OUTFILE.\n" unless $QUIET_ARG;
  257. }
  258.  
  259.  
  260. sub preparation 
  261. {
  262.     $PO_DIR = $ARGV[0];
  263.     $FILE = $ARGV[1];
  264.     $OUTFILE = $ARGV[2];
  265.  
  266.     &gather_po_files;
  267.     &get_translation_database;
  268. }
  269.  
  270. # General-purpose code for looking up translations in .po files
  271.  
  272. sub po_file2lang
  273. {
  274.     my ($tmp) = @_; 
  275.     $tmp =~ s/^.*\/(.*)\.po$/$1/; 
  276.     return $tmp; 
  277. }
  278.  
  279. sub gather_po_files
  280. {
  281.     if (my $linguas = $ENV{"LINGUAS"})
  282.     {
  283.         for my $lang (split / /, $linguas) {
  284.             my $po_file = $PO_DIR . "/" . $lang . ".po";
  285.             if (-e $po_file) {
  286.                 $po_files_by_lang{$lang} = $po_file;
  287.             }
  288.         }
  289.     }
  290.     else
  291.     {
  292.         if (open LINGUAS_FILE, "$PO_DIR/LINGUAS")
  293.         {
  294.             while (<LINGUAS_FILE>)
  295.             {
  296.                 next if /^#/;
  297.  
  298.                 for my $lang (split)
  299.                 {
  300.                     chomp ($lang);
  301.                     my $po_file = $PO_DIR . "/" . $lang . ".po";
  302.                     if (-e $po_file) {
  303.                         $po_files_by_lang{$lang} = $po_file;
  304.                     }
  305.                 }
  306.             }
  307.  
  308.             close LINGUAS_FILE;
  309.         }
  310.         else
  311.         {
  312.             for my $po_file (glob "$PO_DIR/*.po") {
  313.                 $po_files_by_lang{po_file2lang($po_file)} = $po_file;
  314.             }
  315.         }
  316.     }
  317. }
  318.  
  319. sub get_local_charset
  320. {
  321.     my ($encoding) = @_;
  322.     my $alias_file = $ENV{"G_CHARSET_ALIAS"} || "c:/devel/target/c515ef32b598e60d66a45e3c492ddef9/lib/charset.alias";
  323.  
  324.     # seek character encoding aliases in charset.alias (glib)
  325.  
  326.     if (open CHARSET_ALIAS, $alias_file) 
  327.     {
  328.     while (<CHARSET_ALIAS>) 
  329.         {
  330.             next if /^\#/;
  331.             return $1 if (/^\s*([-._a-zA-Z0-9]+)\s+$encoding\b/i)
  332.         }
  333.  
  334.         close CHARSET_ALIAS;
  335.     }
  336.  
  337.     # if not found, return input string
  338.  
  339.     return $encoding;
  340. }
  341.  
  342. sub get_po_encoding
  343. {
  344.     my ($in_po_file) = @_;
  345.     my $encoding = "";
  346.  
  347.     open IN_PO_FILE, $in_po_file or die;
  348.     while (<IN_PO_FILE>) 
  349.     {
  350.         ## example: "Content-Type: text/plain; charset=ISO-8859-1\n"
  351.         if (/Content-Type\:.*charset=([-a-zA-Z0-9]+)\\n/) 
  352.         {
  353.             $encoding = $1; 
  354.             last;
  355.         }
  356.     }
  357.     close IN_PO_FILE;
  358.  
  359.     if (!$encoding) 
  360.     {
  361.         print STDERR "Warning: no encoding found in $in_po_file. Assuming ISO-8859-1\n" unless $QUIET_ARG;
  362.         $encoding = "ISO-8859-1";
  363.     }
  364.  
  365.     system ("$iconv -f $encoding -t UTF-8 <$devnull 2>$devnull");
  366.     if ($?) {
  367.     $encoding = get_local_charset($encoding);
  368.     }
  369.  
  370.     return $encoding
  371. }
  372.  
  373. sub utf8_sanity_check 
  374. {
  375.     print STDERR "Warning: option --pass-through has been removed.\n" if $PASS_THROUGH_ARG;
  376.     $UTF8_ARG = 1;
  377. }
  378.  
  379. sub get_translation_database
  380. {
  381.     if ($cache_file) {
  382.     &get_cached_translation_database;
  383.     } else {
  384.         &create_translation_database;
  385.     }
  386. }
  387.  
  388. sub get_newest_po_age
  389. {
  390.     my $newest_age;
  391.  
  392.     foreach my $file (values %po_files_by_lang) 
  393.     {
  394.     my $file_age = -M $file;
  395.     $newest_age = $file_age if !$newest_age || $file_age < $newest_age;
  396.     }
  397.  
  398.     $newest_age = 0 if !$newest_age;
  399.  
  400.     return $newest_age;
  401. }
  402.  
  403. sub create_cache
  404. {
  405.     print "Generating and caching the translation database\n" unless $QUIET_ARG;
  406.  
  407.     &create_translation_database;
  408.  
  409.     open CACHE, ">$cache_file" || die;
  410.     print CACHE join "\x01", %translations;
  411.     close CACHE;
  412. }
  413.  
  414. sub load_cache 
  415. {
  416.     print "Found cached translation database\n" unless $QUIET_ARG;
  417.  
  418.     my $contents;
  419.     open CACHE, "<$cache_file" || die;
  420.     {
  421.         local $/;
  422.         $contents = <CACHE>;
  423.     }
  424.     close CACHE;
  425.     %translations = split "\x01", $contents;
  426. }
  427.  
  428. sub get_cached_translation_database
  429. {
  430.     my $cache_file_age = -M $cache_file;
  431.     if (defined $cache_file_age) 
  432.     {
  433.         if ($cache_file_age <= &get_newest_po_age) 
  434.         {
  435.             &load_cache;
  436.             return;
  437.         }
  438.         print "Found too-old cached translation database\n" unless $QUIET_ARG;
  439.     }
  440.  
  441.     &create_cache;
  442. }
  443.  
  444. sub add_translation
  445. {
  446.     my ($lang, $msgctxt, $msgid, $msgstr) = @_;
  447.  
  448.     return if !($msgid && $msgstr);
  449.  
  450.     if ($msgctxt) {
  451.     $msgid = "$msgctxt\004$msgid";
  452.     }
  453.     $translations{$lang, $msgid} = $msgstr;
  454. }
  455.  
  456. sub create_translation_database
  457. {
  458.     for my $lang (keys %po_files_by_lang) 
  459.     {
  460.         my $po_file = $po_files_by_lang{$lang};
  461.  
  462.         if ($UTF8_ARG) 
  463.         {
  464.             my $encoding = get_po_encoding ($po_file);
  465.  
  466.             if (lc $encoding eq "utf-8") 
  467.             {
  468.                 open PO_FILE, "<$po_file";    
  469.             } 
  470.             else 
  471.             {
  472.         print "NOTICE: $po_file is not in UTF-8 but $encoding, converting...\n" unless $QUIET_ARG;;
  473.  
  474.                 open PO_FILE, "$iconv -f $encoding -t UTF-8 $po_file|";    
  475.             }
  476.         } 
  477.         else 
  478.         {
  479.             open PO_FILE, "<$po_file";    
  480.         }
  481.  
  482.     my $nextfuzzy = 0;
  483.     my $inmsgctxt = 0;
  484.     my $inmsgid = 0;
  485.     my $inmsgstr = 0;
  486.     my $msgctxt = "";
  487.     my $msgid = "";
  488.     my $msgstr = "";
  489.  
  490.         while (<PO_FILE>) 
  491.         {
  492.         $nextfuzzy = 1 if /^#, fuzzy/;
  493.        
  494.         if (/^msgctxt "((\\.|[^\\]+)*)"/ ) 
  495.             {
  496.         if ($inmsgstr) {
  497.             add_translation ($lang, $msgctxt, $msgid, $msgstr);
  498.             $msgctxt = "";
  499.             $msgid = "";
  500.             $msgstr = "";
  501.         }
  502.  
  503.         $msgctxt = unescape_po_string($1);
  504.         $inmsgctxt = 1;
  505.         $inmsgid = 0;
  506.         $inmsgstr = 0;
  507.         }
  508.  
  509.         if (/^msgid "((\\.|[^\\]+)*)"/ ) 
  510.             {
  511.         if ($inmsgstr) {
  512.             add_translation ($lang, $msgctxt, $msgid, $msgstr);
  513.             $msgctxt = "";
  514.             $msgid = "";
  515.             $msgstr = "";
  516.         }
  517.  
  518.         if ($nextfuzzy) {
  519.             $inmsgid = 0;
  520.             $nextfuzzy = 0;
  521.         } else {
  522.             $msgid = unescape_po_string($1);
  523.             $inmsgid = 1;
  524.         }
  525.         $inmsgctxt = 0;
  526.         $inmsgstr = 0;
  527.         }
  528.  
  529.         if (/^msgstr "((\\.|[^\\]+)*)"/) 
  530.             {
  531.             $msgstr = unescape_po_string($1);
  532.         $inmsgstr = 1;
  533.         $inmsgctxt = 0;
  534.         $inmsgid = 0;
  535.         }
  536.  
  537.         if (/^"((\\.|[^\\]+)*)"/) 
  538.             {
  539.             $msgctxt .= unescape_po_string($1) if $inmsgctxt;
  540.             $msgid .= unescape_po_string($1) if $inmsgid;
  541.             $msgstr .= unescape_po_string($1) if $inmsgstr;
  542.         }
  543.     }
  544.     $translations{$lang, $msgid} = $msgstr if $inmsgstr && $msgid && $msgstr;
  545.     }
  546. }
  547.  
  548. sub finalize
  549. {
  550. }
  551.  
  552. sub unescape_one_sequence
  553. {
  554.     my ($sequence) = @_;
  555.  
  556.     return "\\" if $sequence eq "\\\\";
  557.     return "\"" if $sequence eq "\\\"";
  558.     return "\n" if $sequence eq "\\n";
  559.     return "\r" if $sequence eq "\\r";
  560.     return "\t" if $sequence eq "\\t";
  561.     return "\b" if $sequence eq "\\b";
  562.     return "\f" if $sequence eq "\\f";
  563.     return "\a" if $sequence eq "\\a";
  564.     return chr(11) if $sequence eq "\\v"; # vertical tab, see ascii(7)
  565.  
  566.     return chr(hex($1)) if ($sequence =~ /\\x([0-9a-fA-F]{2})/);
  567.     return chr(oct($1)) if ($sequence =~ /\\([0-7]{3})/);
  568.  
  569.     # FIXME: Is \0 supported as well? Kenneth and Rodney don't want it, see bug #48489
  570.  
  571.     return $sequence;
  572. }
  573.  
  574. sub unescape_po_string
  575. {
  576.     my ($string) = @_;
  577.  
  578.     $string =~ s/(\\x[0-9a-fA-F]{2}|\\[0-7]{3}|\\.)/unescape_one_sequence($1)/eg;
  579.  
  580.     return $string;
  581. }
  582.  
  583. sub entity_decode
  584. {
  585.     local ($_) = @_;
  586.  
  587.     s/'/'/g; # '
  588.     s/"/"/g; # "
  589.     s/</</g;
  590.     s/>/>/g;
  591.     s/&/&/g;
  592.  
  593.     return $_;
  594. }
  595.  
  596. # entity_encode: (string)
  597. #
  598. # Encode the given string to XML format (encode '<' etc).
  599.  
  600. sub entity_encode
  601. {
  602.     my ($pre_encoded) = @_;
  603.  
  604.     my @list_of_chars = unpack ('C*', $pre_encoded);
  605.  
  606.     # with UTF-8 we only encode minimalistic
  607.     return join ('', map (&entity_encode_int_minimalist, @list_of_chars));
  608. }
  609.  
  610. sub entity_encode_int_minimalist
  611. {
  612.     return """ if $_ == 34;
  613.     return "&" if $_ == 38;
  614.     return "'" if $_ == 39;
  615.     return "<" if $_ == 60;
  616.     return ">" if $_ == 62;
  617.     return chr $_;
  618. }
  619.  
  620. sub entity_encoded_translation
  621. {
  622.     my ($lang, $string) = @_;
  623.  
  624.     my $translation = $translations{$lang, $string};
  625.     return $string if !$translation;
  626.     return entity_encode ($translation);
  627. }
  628.  
  629. ## XML (bonobo-activation specific) merge code
  630.  
  631. sub ba_merge_translations
  632. {
  633.     my $source;
  634.  
  635.     {
  636.        local $/; # slurp mode
  637.        open INPUT, "<$FILE" or die "can't open $FILE: $!";
  638.        $source = <INPUT>;
  639.        close INPUT;
  640.     }
  641.  
  642.     open OUTPUT, ">$OUTFILE" or die "can't open $OUTFILE: $!";
  643.     # Binmode so that selftest works ok if using a native Win32 Perl...
  644.     binmode (OUTPUT) if $^O eq 'MSWin32';
  645.  
  646.     while ($source =~ s|^(.*?)([ \t]*<\s*$w+\s+($w+\s*=\s*"$q"\s*)+/?>)([ \t]*\n)?||s) 
  647.     {
  648.         print OUTPUT $1;
  649.  
  650.         my $node = $2 . "\n";
  651.  
  652.         my @strings = ();
  653.         $_ = $node;
  654.     while (s/(\s)_($w+\s*=\s*"($q)")/$1$2/s) {
  655.              push @strings, entity_decode($3);
  656.         }
  657.     print OUTPUT;
  658.  
  659.     my %langs;
  660.     for my $string (@strings) 
  661.         {
  662.         for my $lang (keys %po_files_by_lang) 
  663.             {
  664.                 $langs{$lang} = 1 if $translations{$lang, $string};
  665.         }
  666.     }
  667.     
  668.     for my $lang (sort keys %langs) 
  669.         {
  670.         $_ = $node;
  671.         s/(\sname\s*=\s*)"($q)"/$1"$2-$lang"/s;
  672.         s/(\s)_($w+\s*=\s*")($q)"/$1 . $2 . entity_encoded_translation($lang, $3) . '"'/seg;
  673.         print OUTPUT;
  674.         }
  675.     }
  676.  
  677.     print OUTPUT $source;
  678.  
  679.     close OUTPUT;
  680. }
  681.  
  682.  
  683. ## XML (non-bonobo-activation) merge code
  684.  
  685.  
  686. # Process tag attributes
  687. #   Only parameter is a HASH containing attributes -> values mapping
  688. sub getAttributeString
  689. {
  690.     my $sub = shift;
  691.     my $do_translate = shift || 0;
  692.     my $language = shift || "";
  693.     my $result = "";
  694.     my $translate = shift;
  695.     foreach my $e (reverse(sort(keys %{ $sub }))) {
  696.     my $key    = $e;
  697.     my $string = $sub->{$e};
  698.     my $quote = '"';
  699.     
  700.     $string =~ s/^[\s]+//;
  701.     $string =~ s/[\s]+$//;
  702.     
  703.     if ($string =~ /^'.*'$/)
  704.     {
  705.         $quote = "'";
  706.     }
  707.     $string =~ s/^['"]//g;
  708.     $string =~ s/['"]$//g;
  709.  
  710.     if ($do_translate && $key =~ /^_/) {
  711.         $key =~ s|^_||g;
  712.         if ($language) {
  713.         # Handle translation
  714.         my $decode_string = entity_decode($string);
  715.         my $translation = $translations{$language, $decode_string};
  716.         if ($translation) {
  717.             $translation = entity_encode($translation);
  718.             $string = $translation;
  719.                 }
  720.                 $$translate = 2;
  721.             } else {
  722.                  $$translate = 2 if ($translate && (!$$translate)); # watch not to "overwrite" $translate
  723.             }
  724.     }
  725.     
  726.     $result .= " $key=$quote$string$quote";
  727.     }
  728.     return $result;
  729. }
  730.  
  731. # Returns a translatable string from XML node, it works on contents of every node in XML::Parser tree
  732. sub getXMLstring
  733. {
  734.     my $ref = shift;
  735.     my $spacepreserve = shift || 0;
  736.     my @list = @{ $ref };
  737.     my $result = "";
  738.  
  739.     my $count = scalar(@list);
  740.     my $attrs = $list[0];
  741.     my $index = 1;
  742.  
  743.     $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
  744.     $spacepreserve = 0 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?default["']?$/));
  745.  
  746.     while ($index < $count) {
  747.     my $type = $list[$index];
  748.     my $content = $list[$index+1];
  749.         if (! $type ) {
  750.         # We've got CDATA
  751.         if ($content) {
  752.         # lets strip the whitespace here, and *ONLY* here
  753.                 $content =~ s/\s+/ /gs if (!$spacepreserve);
  754.         $result .= $content;
  755.         }
  756.     } elsif ( "$type" ne "1" ) {
  757.         # We've got another element
  758.         $result .= "<$type";
  759.         $result .= getAttributeString(@{$content}[0], 0); # no nested translatable elements
  760.         if ($content) {
  761.         my $subresult = getXMLstring($content, $spacepreserve);
  762.         if ($subresult) {
  763.             $result .= ">".$subresult . "</$type>";
  764.         } else {
  765.             $result .= "/>";
  766.         }
  767.         } else {
  768.         $result .= "/>";
  769.         }
  770.     }
  771.     $index += 2;
  772.     }
  773.     return $result;
  774. }
  775.  
  776. # Translate list of nodes if necessary
  777. sub translate_subnodes
  778. {
  779.     my $fh = shift;
  780.     my $content = shift;
  781.     my $language = shift || "";
  782.     my $singlelang = shift || 0;
  783.     my $spacepreserve = shift || 0;
  784.  
  785.     my @nodes = @{ $content };
  786.  
  787.     my $count = scalar(@nodes);
  788.     my $index = 0;
  789.     while ($index < $count) {
  790.         my $type = $nodes[$index];
  791.         my $rest = $nodes[$index+1];
  792.         if ($singlelang) {
  793.             my $oldMO = $MULTIPLE_OUTPUT;
  794.             $MULTIPLE_OUTPUT = 1;
  795.             traverse($fh, $type, $rest, $language, $spacepreserve);
  796.             $MULTIPLE_OUTPUT = $oldMO;
  797.         } else {
  798.             traverse($fh, $type, $rest, $language, $spacepreserve);
  799.         }
  800.         $index += 2;
  801.     }
  802. }
  803.  
  804. sub isWellFormedXmlFragment
  805. {
  806.     my $ret = eval 'require XML::Parser';
  807.     if(!$ret) {
  808.         die "You must have XML::Parser installed to run $0\n\n";
  809.     } 
  810.  
  811.     my $fragment = shift;
  812.     return 0 if (!$fragment);
  813.  
  814.     $fragment = "<root>$fragment</root>";
  815.     my $xp = new XML::Parser(Style => 'Tree');
  816.     my $tree = 0;
  817.     eval { $tree = $xp->parse($fragment); };
  818.     return $tree;
  819. }
  820.  
  821. sub traverse
  822. {
  823.     my $fh = shift; 
  824.     my $nodename = shift;
  825.     my $content = shift;
  826.     my $language = shift || "";
  827.     my $spacepreserve = shift || 0;
  828.  
  829.     if (!$nodename) {
  830.     if ($content =~ /^[\s]*$/) {
  831.         $leading_space .= $content;
  832.     }
  833.     print $fh $content;
  834.     } else {
  835.     # element
  836.     my @all = @{ $content };
  837.     my $attrs = shift @all;
  838.     my $translate = 0;
  839.     my $outattr = getAttributeString($attrs, 1, $language, \$translate);
  840.  
  841.     if ($nodename =~ /^_/) {
  842.         $translate = 1;
  843.         $nodename =~ s/^_//;
  844.     }
  845.     my $lookup = '';
  846.  
  847.         $spacepreserve = 0 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?default["']?$/));
  848.         $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
  849.  
  850.     print $fh "<$nodename", $outattr;
  851.     if ($translate) {
  852.         $content = getXMLstring($content, $spacepreserve);
  853.             if (!$spacepreserve) {
  854.                 $content =~ s/^\s+//s;
  855.                 $content =~ s/\s+$//s;
  856.             }
  857.             if (exists $attrs->{"msgctxt"}) {
  858.                 my $context = entity_decode ($attrs->{"msgctxt"});
  859.                 $context =~ s/^["'](.*)["']/$1/;
  860.                 $lookup = "$context\004$content";
  861.             } else {
  862.                 $lookup = $content;
  863.             }
  864.  
  865.         if ($lookup || $translate == 2) {
  866.                 my $translation = $translations{$language, $lookup} if isWellFormedXmlFragment($translations{$language, $lookup});
  867.                 if ($MULTIPLE_OUTPUT && ($translation || $translate == 2)) {
  868.                     $translation = $content if (!$translation);
  869.                     print $fh " xml:lang=\"", $language, "\"" if $language;
  870.                     print $fh ">";
  871.                     if ($translate == 2) {
  872.                         translate_subnodes($fh, \@all, $language, 1, $spacepreserve);
  873.                     } else {
  874.                         print $fh $translation;
  875.                     }
  876.                     print $fh "</$nodename>";
  877.  
  878.                     return; # this means there will be no same translation with xml:lang="$language"...
  879.                             # if we want them both, just remove this "return"
  880.                 } else {
  881.                     print $fh ">";
  882.                     if ($translate == 2) {
  883.                         translate_subnodes($fh, \@all, $language, 1, $spacepreserve);
  884.                     } else {
  885.                         print $fh $content;
  886.                     }
  887.                     print $fh "</$nodename>";
  888.                 }
  889.         } else {
  890.         print $fh "/>";
  891.         }
  892.  
  893.         for my $lang (sort keys %po_files_by_lang) {
  894.                     if ($MULTIPLE_OUTPUT && $lang ne "$language") {
  895.                         next;
  896.                     }
  897.             if ($lang) {
  898.                         # Handle translation
  899.                         #
  900.                         my $translate = 0;
  901.                         my $localattrs = getAttributeString($attrs, 1, $lang, \$translate);
  902.                         my $translation = $translations{$lang, $lookup} if isWellFormedXmlFragment($translations{$lang, $lookup});
  903.                         if ($translate && !$translation) {
  904.                             $translation = $content;
  905.                         }
  906.  
  907.                         if ($translation || $translate) {
  908.                 print $fh "\n";
  909.                 $leading_space =~ s/.*\n//g;
  910.                 print $fh $leading_space;
  911.                  print $fh "<", $nodename, " xml:lang=\"", $lang, "\"", $localattrs, ">";
  912.                             if ($translate == 2) {
  913.                                translate_subnodes($fh, \@all, $lang, 1, $spacepreserve);
  914.                             } else {
  915.                                 print $fh $translation;
  916.                             }
  917.                             print $fh "</$nodename>";
  918.             }
  919.                     }
  920.         }
  921.  
  922.     } else {
  923.         my $count = scalar(@all);
  924.         if ($count > 0) {
  925.         print $fh ">";
  926.                 my $index = 0;
  927.                 while ($index < $count) {
  928.                     my $type = $all[$index];
  929.                     my $rest = $all[$index+1];
  930.                     traverse($fh, $type, $rest, $language, $spacepreserve);
  931.                     $index += 2;
  932.                 }
  933.         print $fh "</$nodename>";
  934.         } else {
  935.         print $fh "/>";
  936.         }
  937.     }
  938.     }
  939. }
  940.  
  941. sub intltool_tree_comment
  942. {
  943.     my $expat = shift;
  944.     my $data  = shift;
  945.     my $clist = $expat->{Curlist};
  946.     my $pos   = $#$clist;
  947.  
  948.     push @$clist, 1 => $data;
  949. }
  950.  
  951. sub intltool_tree_cdatastart
  952. {
  953.     my $expat    = shift;
  954.     my $clist = $expat->{Curlist};
  955.     my $pos   = $#$clist;
  956.  
  957.     push @$clist, 0 => $expat->original_string();
  958. }
  959.  
  960. sub intltool_tree_cdataend
  961. {
  962.     my $expat    = shift;
  963.     my $clist = $expat->{Curlist};
  964.     my $pos   = $#$clist;
  965.  
  966.     $clist->[$pos] .= $expat->original_string();
  967. }
  968.  
  969. sub intltool_tree_char
  970. {
  971.     my $expat = shift;
  972.     my $text  = shift;
  973.     my $clist = $expat->{Curlist};
  974.     my $pos   = $#$clist;
  975.  
  976.     # Use original_string so that we retain escaped entities
  977.     # in CDATA sections.
  978.     #
  979.     if ($pos > 0 and $clist->[$pos - 1] eq '0') {
  980.         $clist->[$pos] .= $expat->original_string();
  981.     } else {
  982.         push @$clist, 0 => $expat->original_string();
  983.     }
  984. }
  985.  
  986. sub intltool_tree_start
  987. {
  988.     my $expat    = shift;
  989.     my $tag      = shift;
  990.     my @origlist = ();
  991.  
  992.     # Use original_string so that we retain escaped entities
  993.     # in attribute values.  We must convert the string to an
  994.     # @origlist array to conform to the structure of the Tree
  995.     # Style.
  996.     #
  997.     my @original_array = split /\x/, $expat->original_string();
  998.     my $source         = $expat->original_string();
  999.  
  1000.     # Remove leading tag.
  1001.     #
  1002.     $source =~ s|^\s*<\s*(\S+)||s;
  1003.  
  1004.     # Grab attribute key/value pairs and push onto @origlist array.
  1005.     #
  1006.     while ($source)
  1007.     {
  1008.        if ($source =~ /^\s*([\w:-]+)\s*[=]\s*["]/)
  1009.        {
  1010.            $source =~ s|^\s*([\w:-]+)\s*[=]\s*["]([^"]*)["]||s;
  1011.            push @origlist, $1;
  1012.            push @origlist, '"' . $2 . '"';
  1013.        }
  1014.        elsif ($source =~ /^\s*([\w:-]+)\s*[=]\s*[']/)
  1015.        {
  1016.            $source =~ s|^\s*([\w:-]+)\s*[=]\s*[']([^']*)[']||s;
  1017.            push @origlist, $1;
  1018.            push @origlist, "'" . $2 . "'";
  1019.        }
  1020.        else
  1021.        {
  1022.            last;
  1023.        }
  1024.     }
  1025.  
  1026.     my $ol = [ { @origlist } ];
  1027.  
  1028.     push @{ $expat->{Lists} }, $expat->{Curlist};
  1029.     push @{ $expat->{Curlist} }, $tag => $ol;
  1030.     $expat->{Curlist} = $ol;
  1031. }
  1032.  
  1033. sub readXml
  1034. {
  1035.     my $filename = shift || return;
  1036.     if(!-f $filename) {
  1037.         die "ERROR Cannot find filename: $filename\n";
  1038.     }
  1039.  
  1040.     my $ret = eval 'require XML::Parser';
  1041.     if(!$ret) {
  1042.         die "You must have XML::Parser installed to run $0\n\n";
  1043.     } 
  1044.     my $xp = new XML::Parser(Style => 'Tree');
  1045.     $xp->setHandlers(Char => \&intltool_tree_char);
  1046.     $xp->setHandlers(Start => \&intltool_tree_start);
  1047.     $xp->setHandlers(CdataStart => \&intltool_tree_cdatastart);
  1048.     $xp->setHandlers(CdataEnd => \&intltool_tree_cdataend);
  1049.     my $tree = $xp->parsefile($filename);
  1050.  
  1051. # <foo><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo>
  1052. # would be:
  1053. # [foo, [{}, head, [{id => "a"}, 0, "Hello ",  em, [{}, 0, "there"]], bar, [{},
  1054. # 0, "Howdy",  ref, [{}]], 0, "do" ] ]
  1055.  
  1056.     return $tree;
  1057. }
  1058.  
  1059. sub print_header
  1060. {
  1061.     my $infile = shift;
  1062.     my $fh = shift;
  1063.     my $source;
  1064.  
  1065.     if(!-f $infile) {
  1066.         die "ERROR Cannot find filename: $infile\n";
  1067.     }
  1068.  
  1069.     print $fh qq{<?xml version="1.0" encoding="UTF-8"?>\n};
  1070.     {
  1071.         local $/;
  1072.         open DOCINPUT, "<${FILE}" or die;
  1073.         $source = <DOCINPUT>;
  1074.         close DOCINPUT;
  1075.     }
  1076.     if ($source =~ /(<!DOCTYPE.*\[.*\]\s*>)/s)
  1077.     {
  1078.         print $fh "$1\n";
  1079.     }
  1080.     elsif ($source =~ /(<!DOCTYPE[^>]*>)/s)
  1081.     {
  1082.         print $fh "$1\n";
  1083.     }
  1084. }
  1085.  
  1086. sub parseTree
  1087. {
  1088.     my $fh        = shift;
  1089.     my $ref       = shift;
  1090.     my $language  = shift || "";
  1091.  
  1092.     my $name = shift @{ $ref };
  1093.     my $cont = shift @{ $ref };
  1094.     
  1095.     while (!$name || "$name" eq "1") {
  1096.         $name = shift @{ $ref };
  1097.         $cont = shift @{ $ref };
  1098.     }
  1099.  
  1100.     my $spacepreserve = 0;
  1101.     my $attrs = @{$cont}[0];
  1102.     $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
  1103.  
  1104.     traverse($fh, $name, $cont, $language, $spacepreserve);
  1105. }
  1106.  
  1107. sub xml_merge_output
  1108. {
  1109.     my $source;
  1110.  
  1111.     if ($MULTIPLE_OUTPUT) {
  1112.         for my $lang (sort keys %po_files_by_lang) {
  1113.         if ( ! -d $lang ) {
  1114.             mkdir $lang or -d $lang or die "Cannot create subdirectory $lang: $!\n";
  1115.             }
  1116.             open OUTPUT, ">$lang/$OUTFILE" or die "Cannot open $lang/$OUTFILE: $!\n";
  1117.             binmode (OUTPUT) if $^O eq 'MSWin32';
  1118.             my $tree = readXml($FILE);
  1119.             print_header($FILE, \*OUTPUT);
  1120.             parseTree(\*OUTPUT, $tree, $lang);
  1121.             close OUTPUT;
  1122.             print "CREATED $lang/$OUTFILE\n" unless $QUIET_ARG;
  1123.         }
  1124.         if ( ! -d "C" ) {
  1125.             mkdir "C" or -d "C" or die "Cannot create subdirectory C: $!\n";
  1126.         }
  1127.         open OUTPUT, ">C/$OUTFILE" or die "Cannot open C/$OUTFILE: $!\n";
  1128.         binmode (OUTPUT) if $^O eq 'MSWin32';
  1129.         my $tree = readXml($FILE);
  1130.         print_header($FILE, \*OUTPUT);
  1131.         parseTree(\*OUTPUT, $tree);
  1132.         close OUTPUT;
  1133.         print "CREATED C/$OUTFILE\n" unless $QUIET_ARG;
  1134.     } else {
  1135.         open OUTPUT, ">$OUTFILE" or die "Cannot open $OUTFILE: $!\n";
  1136.         binmode (OUTPUT) if $^O eq 'MSWin32';
  1137.         my $tree = readXml($FILE);
  1138.         print_header($FILE, \*OUTPUT);
  1139.         parseTree(\*OUTPUT, $tree);
  1140.         close OUTPUT;
  1141.         print "CREATED $OUTFILE\n" unless $QUIET_ARG;
  1142.     }
  1143. }
  1144.  
  1145. sub keys_merge_translation
  1146. {
  1147.     my ($lang) = @_;
  1148.  
  1149.     if ( ! -d $lang && $MULTIPLE_OUTPUT)
  1150.     {
  1151.         mkdir $lang or -d $lang or die "Cannot create subdirectory $lang: $!\n";
  1152.     }
  1153.  
  1154.     open INPUT, "<${FILE}" or die "Cannot open ${FILE}: $!\n";
  1155.     open OUTPUT, ">$lang/$OUTFILE" or die "Cannot open $lang/$OUTFILE: $!\n";
  1156.     binmode (OUTPUT) if $^O eq 'MSWin32';
  1157.  
  1158.     while (<INPUT>)
  1159.     {
  1160.         if (s/^(\s*)_(\w+=(.*))/$1$2/)
  1161.         {
  1162.             my $string = $3;
  1163.  
  1164.             if (!$MULTIPLE_OUTPUT)
  1165.             {
  1166.                 print OUTPUT;
  1167.  
  1168.                 my $non_translated_line = $_;
  1169.  
  1170.                 for my $lang (sort keys %po_files_by_lang)
  1171.                 {
  1172.                     my $translation = $translations{$lang, $string};
  1173.                     next if !$translation;
  1174.  
  1175.                     $_ = $non_translated_line;
  1176.                     s/(\w+)=.*/[$lang]$1=$translation/;
  1177.                     print OUTPUT;
  1178.                 }
  1179.             }
  1180.             else
  1181.             {
  1182.                 my $non_translated_line = $_;
  1183.                 my $translation = $translations{$lang, $string};
  1184.                 $translation = $string if !$translation;
  1185.  
  1186.                 $_ = $non_translated_line;
  1187.                 s/(\w+)=.*/$1=$translation/;
  1188.                 print OUTPUT;
  1189.             }
  1190.         }
  1191.         else
  1192.         {
  1193.             print OUTPUT;
  1194.         }
  1195.     }
  1196.  
  1197.     close OUTPUT;
  1198.     close INPUT;
  1199.  
  1200.     print "CREATED $lang/$OUTFILE\n" unless $QUIET_ARG;
  1201. }
  1202.  
  1203. sub keys_merge_translations
  1204. {
  1205.     if ($MULTIPLE_OUTPUT)
  1206.     {
  1207.         for my $lang (sort keys %po_files_by_lang)
  1208.         {
  1209.             keys_merge_translation ($lang);
  1210.         }
  1211.         keys_merge_translation ("C");
  1212.     }
  1213.     else
  1214.     {
  1215.         keys_merge_translation (".");
  1216.     }
  1217. }
  1218.  
  1219. sub desktop_merge_translations
  1220. {
  1221.     open INPUT, "<${FILE}" or die;
  1222.     open OUTPUT, ">${OUTFILE}" or die;
  1223.     binmode (OUTPUT) if $^O eq 'MSWin32';
  1224.  
  1225.     while (<INPUT>) 
  1226.     {
  1227.         if (s/^(\s*)_([A-Za-z0-9\-]+=(.*))/$1$2/)  
  1228.         {
  1229.         my $string = $3;
  1230.  
  1231.             print OUTPUT;
  1232.  
  1233.         my $non_translated_line = $_;
  1234.  
  1235.             for my $lang (sort keys %po_files_by_lang) 
  1236.             {
  1237.                 my $translation = $translations{$lang, $string};
  1238.                 next if !$translation;
  1239.  
  1240.                 $_ = $non_translated_line;
  1241.                 s/(\w+)=.*/${1}[$lang]=$translation/;
  1242.                 print OUTPUT;
  1243.             }
  1244.     } 
  1245.         else 
  1246.         {
  1247.             print OUTPUT;
  1248.         }
  1249.     }
  1250.  
  1251.     close OUTPUT;
  1252.     close INPUT;
  1253. }
  1254.  
  1255. sub schemas_merge_translations
  1256. {
  1257.     my $source;
  1258.  
  1259.     {
  1260.        local $/; # slurp mode
  1261.        open INPUT, "<$FILE" or die "can't open $FILE: $!";
  1262.        $source = <INPUT>;
  1263.        close INPUT;
  1264.     }
  1265.  
  1266.     open OUTPUT, ">$OUTFILE" or die;
  1267.     binmode (OUTPUT) if $^O eq 'MSWin32';
  1268.  
  1269.     # FIXME: support attribute translations
  1270.  
  1271.     # Empty nodes never need translation, so unmark all of them.
  1272.     # For example, <_foo/> is just replaced by <foo/>.
  1273.     $source =~ s|<\s*_($w+)\s*/>|<$1/>|g;
  1274.  
  1275.     while ($source =~ s/
  1276.                         (.*?)
  1277.                         (\s+)(<locale\ name="C">(\s*)
  1278.                             (<default>\s*(?:<!--[^>]*?-->\s*)?(.*?)\s*<\/default>)?(\s*)
  1279.                             (<short>\s*(?:<!--[^>]*?-->\s*)?(.*?)\s*<\/short>)?(\s*)
  1280.                             (<long>\s*(?:<!--[^>]*?-->\s*)?(.*?)\s*<\/long>)?(\s*)
  1281.                         <\/locale>)
  1282.                        //sx) 
  1283.     {
  1284.         print OUTPUT $1;
  1285.  
  1286.     my $locale_start_spaces = $2 ? $2 : '';
  1287.     my $default_spaces = $4 ? $4 : '';
  1288.     my $short_spaces = $7 ? $7 : '';
  1289.     my $long_spaces = $10 ? $10 : '';
  1290.     my $locale_end_spaces = $13 ? $13 : '';
  1291.     my $c_default_block = $3 ? $3 : '';
  1292.     my $default_string = $6 ? $6 : '';
  1293.     my $short_string = $9 ? $9 : '';
  1294.     my $long_string = $12 ? $12 : '';
  1295.  
  1296.     print OUTPUT "$locale_start_spaces$c_default_block";
  1297.  
  1298.         $default_string =~ s/\s+/ /g;
  1299.         $default_string = entity_decode($default_string);
  1300.     $short_string =~ s/\s+/ /g;
  1301.     $short_string = entity_decode($short_string);
  1302.     $long_string =~ s/\s+/ /g;
  1303.     $long_string = entity_decode($long_string);
  1304.  
  1305.     for my $lang (sort keys %po_files_by_lang) 
  1306.         {
  1307.         my $default_translation = $translations{$lang, $default_string};
  1308.         my $short_translation = $translations{$lang, $short_string};
  1309.         my $long_translation  = $translations{$lang, $long_string};
  1310.  
  1311.         next if (!$default_translation && !$short_translation && 
  1312.                      !$long_translation);
  1313.  
  1314.         print OUTPUT "\n$locale_start_spaces<locale name=\"$lang\">";
  1315.  
  1316.         print OUTPUT "$default_spaces";    
  1317.  
  1318.         if ($default_translation)
  1319.         {
  1320.             $default_translation = entity_encode($default_translation);
  1321.             print OUTPUT "<default>$default_translation</default>";
  1322.         }
  1323.  
  1324.         print OUTPUT "$short_spaces";
  1325.  
  1326.         if ($short_translation)
  1327.         {
  1328.             $short_translation = entity_encode($short_translation);
  1329.             print OUTPUT "<short>$short_translation</short>";
  1330.         }
  1331.  
  1332.         print OUTPUT "$long_spaces";
  1333.  
  1334.         if ($long_translation)
  1335.         {
  1336.             $long_translation = entity_encode($long_translation);
  1337.             print OUTPUT "<long>$long_translation</long>";
  1338.         }        
  1339.  
  1340.         print OUTPUT "$locale_end_spaces</locale>";
  1341.         }
  1342.     }
  1343.  
  1344.     print OUTPUT $source;
  1345.  
  1346.     close OUTPUT;
  1347. }
  1348.  
  1349. sub rfc822deb_merge_translations
  1350. {
  1351.     my %encodings = ();
  1352.     for my $lang (keys %po_files_by_lang) {
  1353.         $encodings{$lang} = ($UTF8_ARG ? 'UTF-8' : get_po_encoding($po_files_by_lang{$lang}));
  1354.     }
  1355.  
  1356.     my $source;
  1357.  
  1358.     $Text::Wrap::huge = 'overflow';
  1359.     $Text::Wrap::break = qr/\n|\s(?=\S)/;
  1360.  
  1361.     {
  1362.        local $/; # slurp mode
  1363.        open INPUT, "<$FILE" or die "can't open $FILE: $!";
  1364.        $source = <INPUT>;
  1365.        close INPUT;
  1366.     }
  1367.  
  1368.     open OUTPUT, ">${OUTFILE}" or die;
  1369.     binmode (OUTPUT) if $^O eq 'MSWin32';
  1370.  
  1371.     while ($source =~ /(^|\n+)(_*)([^:\s]+)(:[ \t]*)(.*?)(?=\n[\S\n]|$)/sg)
  1372.     {
  1373.         my $sep = $1;
  1374.         my $non_translated_line = $3.$4;
  1375.         my $string = $5;
  1376.         my $underscore = length($2);
  1377.         next if $underscore eq 0 && $non_translated_line =~ /^#/;
  1378.         #  Remove [] dummy strings
  1379.         my $stripped = $string;
  1380.         $stripped =~ s/\[\s[^\[\]]*\],/,/g if $underscore eq 2;
  1381.         $stripped =~ s/\[\s[^\[\]]*\]$//;
  1382.         $non_translated_line .= $stripped;
  1383.  
  1384.         print OUTPUT $sep.$non_translated_line;
  1385.     
  1386.         if ($underscore) 
  1387.         {
  1388.             my @str_list = rfc822deb_split($underscore, $string);
  1389.  
  1390.             for my $lang (sort keys %po_files_by_lang) 
  1391.                 {
  1392.                     my $is_translated = 1;
  1393.                     my $str_translated = '';
  1394.                     my $first = 1;
  1395.                 
  1396.                     for my $str (@str_list) 
  1397.                     {
  1398.                         my $translation = $translations{$lang, $str};
  1399.                     
  1400.                         if (!$translation) 
  1401.                         {
  1402.                             $is_translated = 0;
  1403.                             last;
  1404.                         }
  1405.  
  1406.                     #  $translation may also contain [] dummy
  1407.                         #  strings, mostly to indicate an empty string
  1408.                     $translation =~ s/\[\s[^\[\]]*\]$//;
  1409.                         
  1410.                         if ($first) 
  1411.                         {
  1412.                             if ($underscore eq 2)
  1413.                             {
  1414.                                 $str_translated .= $translation;
  1415.                             }
  1416.                             else
  1417.                             {
  1418.                                 $str_translated .=
  1419.                                     Text::Tabs::expand($translation) .
  1420.                                     "\n";
  1421.                             }
  1422.                         } 
  1423.                         else 
  1424.                         {
  1425.                             if ($underscore eq 2)
  1426.                             {
  1427.                                 $str_translated .= ', ' . $translation;
  1428.                             }
  1429.                             else
  1430.                             {
  1431.                                 $str_translated .= Text::Tabs::expand(
  1432.                                     Text::Wrap::wrap(' ', ' ', $translation)) .
  1433.                                     "\n .\n";
  1434.                             }
  1435.                         }
  1436.                         $first = 0;
  1437.  
  1438.                         #  To fix some problems with Text::Wrap::wrap
  1439.                         $str_translated =~ s/(\n )+\n/\n .\n/g;
  1440.                     }
  1441.                     next unless $is_translated;
  1442.  
  1443.                     $str_translated =~ s/\n \.\n$//;
  1444.                     $str_translated =~ s/\s+$//;
  1445.  
  1446.                     $_ = $non_translated_line;
  1447.                     s/^(\w+):\s*.*/$sep${1}-$lang.$encodings{$lang}: $str_translated/s;
  1448.                     print OUTPUT;
  1449.                 }
  1450.         }
  1451.     }
  1452.     print OUTPUT "\n";
  1453.  
  1454.     close OUTPUT;
  1455.     close INPUT;
  1456. }
  1457.  
  1458. sub rfc822deb_split 
  1459. {
  1460.     # Debian defines a special way to deal with rfc822-style files:
  1461.     # when a value contain newlines, it consists of
  1462.     #   1.  a short form (first line)
  1463.     #   2.  a long description, all lines begin with a space,
  1464.     #       and paragraphs are separated by a single dot on a line
  1465.     # This routine returns an array of all paragraphs, and reformat
  1466.     # them.
  1467.     # When first argument is 2, the string is a comma separated list of
  1468.     # values.
  1469.     my $type = shift;
  1470.     my $text = shift;
  1471.     $text =~ s/^[ \t]//mg;
  1472.     return (split(/, */, $text, 0)) if $type ne 1;
  1473.     return ($text) if $text !~ /\n/;
  1474.  
  1475.     $text =~ s/([^\n]*)\n//;
  1476.     my @list = ($1);
  1477.     my $str = '';
  1478.  
  1479.     for my $line (split (/\n/, $text)) 
  1480.     {
  1481.         chomp $line;
  1482.         if ($line =~ /^\.\s*$/)
  1483.         {
  1484.             #  New paragraph
  1485.             $str =~ s/\s*$//;
  1486.             push(@list, $str);
  1487.             $str = '';
  1488.         } 
  1489.         elsif ($line =~ /^\s/) 
  1490.         {
  1491.             #  Line which must not be reformatted
  1492.             $str .= "\n" if length ($str) && $str !~ /\n$/;
  1493.             $line =~ s/\s+$//;
  1494.             $str .= $line."\n";
  1495.         } 
  1496.         else 
  1497.         {
  1498.             #  Continuation line, remove newline
  1499.             $str .= " " if length ($str) && $str !~ /\n$/;
  1500.             $str .= $line;
  1501.         }
  1502.     }
  1503.  
  1504.     $str =~ s/\s*$//;
  1505.     push(@list, $str) if length ($str);
  1506.  
  1507.     return @list;
  1508. }
  1509.  
  1510. sub quoted_translation
  1511. {
  1512.     my ($xml_mode, $lang, $string) = @_;
  1513.  
  1514.     $string = entity_decode($string) if $xml_mode;
  1515.     $string =~ s/\\\"/\"/g;
  1516.  
  1517.     my $translation = $translations{$lang, $string};
  1518.     $translation = $string if !$translation;
  1519.     $translation = entity_encode($translation) if $xml_mode;
  1520.     $translation =~ s/\"/\\\"/g;
  1521.     return $translation
  1522. }
  1523.  
  1524. sub quoted_merge_translations
  1525. {
  1526.     my ($xml_mode) = @_;
  1527.  
  1528.     if (!$MULTIPLE_OUTPUT) {
  1529.         print "Quoted only supports Multiple Output.\n";
  1530.         exit(1);
  1531.     }
  1532.  
  1533.     for my $lang (sort keys %po_files_by_lang) {
  1534.         if ( ! -d $lang ) {
  1535.             mkdir $lang or -d $lang or die "Cannot create subdirectory $lang: $!\n";
  1536.         }
  1537.         open INPUT, "<${FILE}" or die;
  1538.         open OUTPUT, ">$lang/$OUTFILE" or die "Cannot open $lang/$OUTFILE: $!\n";
  1539.         binmode (OUTPUT) if $^O eq 'MSWin32';
  1540.         while (<INPUT>) 
  1541.         {
  1542.             s/\"(([^\"]|\\\")*[^\\\"])\"/"\"" . "ed_translation($xml_mode, $lang, $1) . "\""/ge;
  1543.             print OUTPUT;
  1544.         }
  1545.         close OUTPUT;
  1546.         close INPUT;
  1547.     }
  1548. }
  1549.